Visual Basic Toolbox/Visual Basic Toolbox (P.I.E.)(1996).ISO/internet/vbipsmtp/dssock.bas

BASIC Source File | 1996-03-12 | 12.3 KB | 475 lines

Attribute VB_Name = "modDSSock"
Option Explicit
'---------------------------------------------------
'DSSOCK.BAS
'Copyright 1996 by Carl Franklin
'Unauthorized reproduction in any medium of this
'source code is strictly prohibited without written
'permission from the author and John Wiley & Sons.
'---------------------------------------------------
'-- The Socket array holds information about the socket
'   controls.
Type SockStatusType
    Connected As Integer  '-- Is the socket connected?
    SendReady As Integer  '-- Is the socket ready to send data?
End Type
Global Socket() As SockStatusType

'-- gnNumSockets holds the number of loaded socket controls.
Global gnNumSockets As Integer

'-- gnConnected is True when the client is connected.
'   Place the line "gnConnected = True" in the client's
'   Connect event.
Global gnConnected As Integer

'-- gnSendReady is True when the client is ready to send.
'   Place the line "gnSendReady = True" in the client's
'   SendReady event.
Global gnSendReady As Integer

Global Const SOCK_ACTION_CLOSE = 1
Global Const SOCK_ACTION_CONNECT = 2
Global Const SOCK_ACTION_LISTEN = 3
Global Const SOCK_ACTION_UDP_CLIENT = 4
Global Const SOCK_ACTION_UDP_SERVER = 5
Global Const SOCK_ERR_CLOSED = 20000

Global Const SOCK_STATE_CLOSED = 1
Global Const SOCK_STATE_CONNECTED = 2
Global Const SOCK_STATE_LISTENING = 3
Global Const SOCK_STATE_CONNECTING = 4
Global Const SOCK_STATE_ERROR = 5
Global Const SOCK_STATE_CLOSING = 6
Global Const SOCK_STATE_UNKNOWN = 7
Global Const SOCK_STATE_BUSY = 8
Global Const SOCK_STATE_UDPACTIVATING = 9
Global Const SOCK_STATE_UDPACTIVE = 10

Global Const SOCK_ERR_OPERATIONWOULDBLOCK = 21035

Global Const ERR_TIMEOUT_CONNECTING = 2
Global Const ERR_TIMEOUT_DISCONNECTING = 3
Global Const ERR_CONNECT = 4

'-- Error log file name. Change if desired
Global Const szLogFileName = "ERRORLOG.TXT"

'-- Which debug option is used
Global nDebugMode As Integer

Global Const DEBUG_MODE_MINIMAL = 0
Global Const DEBUG_MODE_DESIGNTIME = 1
Global Const DEBUG_MODE_DIALOG = 2
Global Const DEBUG_MODE_WRITELOG = 3


Function szStripHTML(szString As String) As String
'-- szStripHTML by Carl Franklin
'   This function strips HTML codes from a string
'   and attempts to reformat with CRLFs.


    Dim szTemp As String
    Dim szResult As String
    Dim nPos As Integer
    Dim nMarker As Integer

    '-- Copy the argument into a local
    '   string so the original does not
    '   get whacked.
    szTemp = szString

    '-- Remove HTML codes
    Do
        nPos = InStr(szTemp, "<")
        If nPos = False Then
            Exit Do
        Else
            '-- szResult contains the final
            '   product of this routine.
            szResult = szResult & _
                Left$(szTemp, nPos - 1)
            '-- szTemp is the working string,
            '   which is continuously
            '   shortened as new codes
            '   are found
            szTemp = Mid$(szTemp, nPos + 1)
            nPos = InStr(szTemp, ">")
            If nPos = False Then
                '-- No complimentary arrow
                '   was found.
                Exit Do
            Else
                '-- What was the code?
                Select Case szParseString(UCase$(Left$(szTemp, nPos - 1)), " ", 1)
                    Case "P", "/H1", "/H2", "/H3", "/H4", "/H5", "DL"
                        szResult = szResult & vbCrLf & vbCrLf
                    Case "BR"
                        szResult = szResult & vbCrLf
                    Case "HR"
                        szResult = szResult & vbCrLf & String$(50, "-") & vbCrLf
                End Select


                '-- Shorten the working
                '   string
                szTemp = Mid$(szTemp, _
                    nPos + 1)
            End If
        End If
    Loop


    '-- Find a marker byte by looking for
    '   a char that does not already exist
    '   in the string.
    For nMarker = 255 To 1 Step -1
        If InStr(szResult, Chr$(nMarker)) = 0 Then
            Exit For
        End If
    Next

    '-- Remove carriage returns
    Do
        nPos = InStr(szResult, vbCr)
        If nPos Then
            szResult = Left$(szResult, _
                nPos - 1) & Mid$(szResult, _
                nPos + 1)
        Else
            Exit Do
        End If
    Loop

    '-- Replace linefeeds with Marker bytes
    Do
        nPos = InStr(szResult, vbLf)
        If nPos Then
            szResult = Left$(szResult, _
                nPos - 1) & Chr$(nMarker) _
                & Mid$(szResult, nPos + 1)
        Else
            Exit Do
        End If
    Loop

    '-- Replace marker bytes with CR/LF pairs
    Do
        nPos = InStr(szResult, Chr$(nMarker))
        If nPos Then
            szResult = Left$(szResult, _
                nPos - 1) & vbCrLf _
                & Trim$(Mid$(szResult, nPos + 1))
        Else
            Exit Do
        End If
    Loop

    '-- Thats all for this routine!
    szStripHTML = szResult

End Function

Function szParseString(szString As String, szDelimiter As String, nSegmentNumber As Integer) As String
'-- Returns a segment of a string given the string,
'   the delimiter, and the segment number

    Dim nIndex  As Integer
    Dim szTemp  As String
    Dim nPos    As Integer

    '-- Save the string so it does not
    '   get whacked
    szTemp = szString

    '-- Strip off the left portion up to the
    '   segment we want
    For nIndex = 1 To nSegmentNumber - 1
        nPos = InStr(szTemp, szDelimiter)
        If nPos Then
            szTemp = Mid$(szTemp, nPos + 1)
        Else
            Exit Function
        End If
    Next

    '-- Find the next delimiter
    nPos = InStr(szTemp, szDelimiter)
    '-- Did we find one?
    If nPos Then
        '-- Yep. return everything up to it
        szParseString = Left$(szTemp, nPos - 1)
    Else
        '-- Not found.. return the rest of the
        '   string as is.
        szParseString = szTemp
    End If

End Function

Sub GetDebugMode()

    Dim szCmd As String
    Dim nPos As Integer

    szCmd = Trim$(UCase$(Command$))

    '-- Are there any command line options?
    If Len(Command) = 0 Then
        '-- No. Exit
        Exit Sub
    Else
        nPos = InStr(Command, "/D")
        If nPos Then
            nDebugMode = Val(Mid$(Command$, nPos + 2, 1))
        End If
    End If

End Sub

Function szTrimCRLF(szString As String) As String

    Dim lStr As Integer

    lStr = Len(szString)

    If lStr Then
        If Right$(szString, 2) = vbCrLf Then
            szTrimCRLF = Left$(szString, lStr - 2)
        Else
            Select Case Right$(szString, 1)
                Case vbLf, vbCr
                    szTrimCRLF = Left$(szString, lStr - 1)
                Case Else
                    szTrimCRLF = szString
            End Select
        End If
    End If


End Function

Sub WriteLogFile(szData As String)

    '-- File handle for the log file (if used)
    Static nLogFileNum As Integer

    On Error Resume Next

    If InStr(UCase$(Command$), "/D") Then
        '-- Is the file not open yet?
        If nLogFileNum = 0 Then
            '-- Open it
            nLogFileNum = FreeFile
            Open App.Path & "\" & szLogFileName For Binary As nLogFileNum
            Seek #nLogFileNum, LOF(nLogFileNum) + 1
        End If

        '-- Write the string
        szData = Str$(Now) & Chr$(9) & szData & vbCrLf
        Put #nLogFileNum, , szData
    End If

End Sub

Sub SendData(DSSock As Control, szData As String)

    WriteLogFile "SendData (100): " & Mid$(szData, 1, 100)

    gnSendReady = False

    On Error Resume Next
    DSSock.Send = szData
    If Err = SOCK_ERR_OPERATIONWOULDBLOCK Then
        Do
            DoEvents
        Loop Until gnSendReady
        DSSock.Send = szData
    ElseIf Err Then
        WriteLogFile "SendData Error: " & Error
    End If

End Sub



Function IsDotAddress(szAddress As String) As Integer

    '-- This function determines if a string is an IP address like
    '   199.200.199.120 or not

    Dim nPos As Integer
    Dim nIndex As Integer
    Dim szSection As String
    Dim szTemp As String

    szTemp = szAddress
    szAddress = Trim$(szAddress)

    For nIndex = 1 To 3
        nPos = InStr(szAddress, ".")
        If nPos Then
            szSection = Left$(szAddress, nPos - 1)
            If Len(szSection) = 0 Then
                Exit Function
            ElseIf Trim$(Str$(Val(szSection))) <> szSection Then
                Exit Function
            ElseIf Val(szSection) > 255 Then
                Exit Function
            ElseIf Val(szSection) < 0 Then
                Exit Function
            End If
            szAddress = Mid$(szAddress, nPos + 1)
        Else
            Exit Function
        End If
    Next

    If Len(szAddress) = 0 Then
        Exit Function
    ElseIf Trim$(Str$(Val(szAddress))) <> szAddress Then
        Exit Function
    ElseIf Val(szAddress) > 255 Then
        Exit Function
    ElseIf Val(szAddress) < 0 Then
        Exit Function
    End If

    szAddress = szTemp
    IsDotAddress = True

End Function

Function SocketConnect(dsSocket As Control, lPort As Long, szHostAddress As String, nTimeout As Integer) As Integer

    Dim EndTime    As Variant

    On Error Resume Next

    '-- Close the connection
    dsSocket.Action = SOCK_ACTION_CLOSE

    '-- Set the specified port
    dsSocket.RemotePort = lPort

    '-- Is this a DOT address or a name?
    If IsDotAddress(szHostAddress) Then
        dsSocket.RemoteDotAddr = szHostAddress
    Else
        dsSocket.RemoteHost = szHostAddress
    End If

    '-- Reset Err and gnConnected
    Err = 0
    gnConnected = False

    '-- Attempt to Connect
    dsSocket.Action = SOCK_ACTION_CONNECT
    If Err Then
        '-- Exit with connect error
        SocketConnect = ERR_CONNECT
        Exit Function
    End If

    '-- Wait for the specified period of time
    '   for the connection to be made
    EndTime = DateAdd("s", nTimeout, Now)
    Do
        DoEvents
        If Now >= EndTime Then
            '-- Time's up. Exit with timeout Error
            SocketConnect = ERR_TIMEOUT_CONNECTING
            Exit Function
        End If
    Loop Until gnConnected = True

    '-- We've connected!
    SocketConnect = False

End Function

Sub SocketDisconnect(Ctrl As Control)

    WriteLogFile "SocketDisconnect"

    On Error Resume Next
    Ctrl.Action = SOCK_ACTION_CLOSE
    gnConnected = False

End Sub

Function SuperTrim$(szString As String)

    Dim nAscFind As Integer
    Dim nAscReplace As Integer
    Dim nMark As Integer

    nAscFind = 9
    nAscReplace = 32
    GoSub RemoveAscii

    nAscFind = 0
    nAscReplace = 32
    GoSub RemoveAscii

    nAscFind = 13
    nAscReplace = 32
    GoSub RemoveAscii

    nAscFind = 10
    nAscReplace = 32
    GoSub RemoveAscii

    SuperTrim$ = Trim$(szString)

    Exit Function

RemoveAscii:

    Do
        nMark = InStr(szString, Chr$(nAscFind))
        If nMark = 0 Then
            Exit Do
        Else
            If nMark < Len(szString) Then
                szString = Left$(szString, nMark - 1) & Chr$(nAscReplace) & Mid$(szString, nMark + 1)
            Else
                szString = Left$(szString, nMark - 1) & Chr$(nAscReplace)
            End If
        End If
    Loop
    Return
End Function

Function szLFToCRLF(szData As String) As String

    Dim nLen As Integer

    nLen = Len(szData)

    '-- Make sure the line ends with CRLF and not just LF
    If Right$(szData, 1) = vbLf Then
        If nLen = 1 Then
            If szData = vbLf Then
                szData = vbCrLf
            End If
        Else
            If Mid$(szData, nLen - 1, 1) <> vbCr Then
                szData = Left$(szData, nLen - 1) & vbCrLf
            End If
        End If
    Else
        If Right$(szData, 1) = vbCr Then
            szData = szData & vbLf
        Else
            szData = szData & vbCrLf
        End If
    End If

    szLFToCRLF = szData

End Function